home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DIRS.SWG / 0038_Recursive Directory lister.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  2KB  |  134 lines
  1. {$M 65520,0,655360}
  2.  
  3. Uses DOS;
  4.  
  5. Type
  6.  String12 = string[12];
  7.  
  8. Const
  9.  FAttr : word = $23; { readonly-, hidden-, archive attributen }
  10.  
  11. Var
  12.  CurDir : PathStr;
  13.  StartDir: DirStr;
  14.  FMask  : String12;
  15.  subdirs : boolean;
  16.  
  17.  
  18. Function UpStr(const s:string):string; assembler;
  19. { by Brain Pape, found in the SWAG collection }
  20. asm
  21.  push ds
  22.  lds si,s
  23.  les di,@result
  24.  lodsb{ load and store length of string }
  25.  stosb
  26.  xor ch,ch
  27.  mov cl,al
  28.  @upperLoop:
  29.  lodsb
  30.  cmp al,'a'
  31.  jb  @cont
  32.  cmp al,'z'
  33.  ja  @cont
  34.  sub al,' '
  35.  @cont:
  36.  stosb
  37.  loop @UpperLoop
  38.  pop ds
  39. end; { UpStr }
  40.  
  41.  
  42. Procedure ParseCmdLine;
  43. var
  44.  t : byte;
  45.  cmd: string;
  46. begin
  47.  for t := 2 to ParamCount do begin
  48. cmd := UpStr(Copy(ParamStr(t),1,2));
  49. if cmd = '/S' then subdirs := true;
  50.  end;
  51. end;
  52.  
  53.  
  54. Function NoTrailingBackslash (path : String) : String;
  55. begin
  56.  if (length(path) > 3) and (path[length(path)] = '\') then
  57.   path[0] := chr(length(path) - 1);
  58.  NoTrailingBackslash := path;
  59. end;
  60.  
  61.  
  62. Procedure PathAnalyze (P: PathStr; Var D: DirStr; Var Name: String12);
  63. Var
  64.  N: NameStr;
  65.  E: ExtStr;
  66.  
  67. begin
  68.  FSplit(P, D, N, E);
  69.  Name := N + E;
  70. end;
  71.  
  72.  
  73. Procedure Process (var SR: SearchRec);
  74. { here you can put anything you want to do in each directory with each file }
  75. begin
  76.  writeln(FExpand(SR.Name));
  77. end;
  78.  
  79.  
  80. Procedure FindFiles;
  81. var
  82.  FR : SearchRec;
  83.  
  84. begin
  85.  FindFirst(FMask, FAttr, FR);
  86.  while DosError = 0 do
  87.  begin
  88. Process(FR);
  89. FindNext(FR);
  90.  end;
  91. end;
  92.  
  93.  
  94. {$S+}
  95. Procedure AllDirs;
  96. { recursively roam through subdirectories }
  97. var
  98.  DR : SearchRec;
  99.  
  100. begin
  101.  FindFirst('*.*', Directory, DR);
  102.  while DosError = 0 do begin
  103. if DR.Attr and Directory = Directory then begin
  104.  if ((DR.Name <> '.') and (DR.Name <> '..')) then begin
  105. ChDir(DR.Name);
  106. AllDirs;  { Recursion!!! }
  107. ChDir('..');
  108.  end
  109. end;
  110. FindNext(DR);
  111.  end;
  112.  FindFiles;
  113. end;
  114. {$S-}
  115.  
  116.  
  117. begin
  118.  
  119.  subdirs := false;
  120.  GetDir (0, CurDir);
  121.  if ParamCount > 1 then ParseCmdLine;
  122.  
  123.  PathAnalyze (FExpand(ParamStr(1)), StartDir, FMask);
  124.  if Length (StartDir) > 0 then ChDir (NoTrailingBackslash(StartDir));
  125.  if IOResult <> 0 then
  126.  begin
  127. Writeln('Cannot find directory.');
  128. Halt(1);
  129.  end;
  130.  if Length (FMask) = 0 then FMask := '*.*';
  131.  if subdirs then AllDirs else FindFiles;
  132.  ChDir (CurDir);
  133. end.
  134.